home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / SCA.PRG < prev    next >
Encoding:
Text File  |  1993-11-19  |  17.2 KB  |  426 lines
  1. *-----------------------------------------------------------------------
  2. *-- Program...: SCA.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 08/27/1993
  5. *-- Notes.....: This file contains the SCA Date handling routines, as 
  6. *--             well as a copy of the roman numeral to arabic and 
  7. *--             vice-versa functions, that are contained in CONVERT.PRG.
  8. *--             This is due to the fact that only two library files may 
  9. *--             be open at one time. See the file README.TXT for more 
  10. *--             details on the use of this library file.
  11. *-----------------------------------------------------------------------
  12.  
  13. PROCEDURE SCA_Real
  14. *-----------------------------------------------------------------------
  15. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) 
  16. *--               (CIS: 71333,1030)
  17. *-- Date........: 07/29/1991
  18. *-- Notes.......: This procedure was designed to handle data entered 
  19. *--               into the Order of Precedence of the Principality of 
  20. *--               the Mists. The problem is, my usual sources of data 
  21. *--               give only SCA dates, and in order to sort properly, 
  22. *--               I need real dates. This procedure will handle it, and 
  23. *--               goes hand-in-hand with the function Real_SCA, to 
  24. *--               translate real dates to SCA dates ... This procedure 
  25. *--               assumes that you have set the F1 Key (see Example 
  26. *--               below). If you use a different F key, you will want 
  27. *--               to modify the ON KEY LABEL commands ...
  28. *-- Written for.: dBASE IV, 1.1
  29. *-- Rev. History: 07/23/1991 - original procedure.
  30. *--               07/29/1991  -- modified it to stuff a character 
  31. *--               directly into a date field (was having to do a CTOD 
  32. *--               in the program), and added use of ESC to escape out, 
  33. *--               instead of killing the procedure and the program 
  34. *--               calling it ...
  35. *-- Calls.......: CENTER               Procedure in PROC.PRG
  36. *--               SHADOW               Procedure in PROC.PRG
  37. *--               ARABIC()             Function in PROC.PRG
  38. *--               ALLTRIM()            Function in PROC.PRG
  39. *-- Called by...: Any
  40. *-- Usage.......: do SCA_Real
  41. *-- Example.....: on key label f1 do sca_real
  42. *--               store {} to t_date   && initialize as a date
  43. *--               clear
  44. *--               @5,10 say "Enter a date:" get t_date;
  45. *--                  message ;
  46. *--                  "Press <F1> to convert from SCA date to real date"
  47. *--               read
  48. *--               on key label f1  && clear out that command ...
  49. *-- Returns.....: real date, forced into field ...
  50. *-- Parameters..: None
  51. *-----------------------------------------------------------------------
  52.    
  53.    private cEscape,cExact,cYear,cMonth,cDay,nYearlen,nCount,nYear,;
  54.            nMonth,nDay,cDate
  55.    
  56.    m->cEscape = set("ESCAPE")
  57.    set escape off            && so we can handle the Escape Key
  58.    m->cExact = set("EXACT")
  59.    set exact on              && VERY important ...
  60.    on key label F1 ?? chr(7) && make it beep, rather than call this 
  61.                              && procedure again, which causes 
  62.                              && wierdnesses ...
  63.  
  64.    *-- first let's popup a window to ask for the information ...
  65.    save screen to sDate
  66.    activate screen
  67.    define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
  68.    do shadow with 8,20,15,60
  69.    activate window wDate
  70.    
  71.    *-- set the memvars ...
  72.    m->cYear  = space(8)
  73.    m->cMonth = space(3)
  74.    m->cDay   = space(2)
  75.    
  76.    do center with 0,40,"","Enter SCA Date below:"
  77.    do while .t.
  78.       @2,14 say "Month: " get m->cMonth ;
  79.          picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
  80.          message ;
  81.          "Enter first letter of month, <Space> to scroll through, "+;
  82.          "<Enter> to choose" color rg+/gb,n/g
  83.       @3,14 say "  Day: " get m->cDay picture "99";
  84.          message;
  85.          "Enter 2 digits for day of the month, if blank will assume 15";
  86.          color rg+/gb,n/g
  87.       @4,14 say " Year: " get m->cYear picture "!!!!!!!!" ;
  88.          message "Enter year in AS roman numeral format";
  89.          valid required len(trim(m->cYear)) > 0;
  90.          error chr(7)+"This is no good without a year ..." ;
  91.          color rg+/gb,n/g
  92.    
  93.        read
  94.    
  95.        if lastkey() = 27       && if user wants out by pressing <Esc>
  96.           release window wDate
  97.           restore screen from sDate
  98.           release screen sDate
  99.           set escape &cEscape.
  100.           set exact &cExact.
  101.           on key label F1 do SCA_Real   && reset it ...
  102.           RETURN
  103.        endif
  104.       
  105.        if lastkey() < 0  && function key F1 through Shift F9 was pressed
  106.           ?? chr(7)      && beep at user
  107.           loop           && don't let 'em get away with that -- 
  108.                          && try again
  109.        endif
  110.       
  111.        *-- check for valid roman numerals
  112.        m->cYear = trim(m->cYear)    && trim it
  113.        m->nYearLen = len(m->cYear)  && get length
  114.        m->nCount = 0            
  115.        do while m->nCount < m->nYearLen  && loop through length of year
  116.           m->nCount = m->nCount + 1      && increment
  117.           if .not. substr(m->cYear,m->nCount,1) $ "IVXLC" 
  118.                                          && if it's not here
  119.              do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
  120.              lError = .t.          && set error flag
  121.              exit                  && exit internal loop
  122.           else
  123.              lError = .f.          && make sure this is false
  124.           endif
  125.        enddo     && end of internal loop
  126.        if lError && if error,
  127.           loop   && go back ...
  128.        endif
  129.       
  130.        @5,0 clear   && clear out any error message ...
  131.        do center with 5,40,"rg+/r","Converting Date ..."
  132.       
  133.        *-- First (and most important) is conversion of the year
  134.        m->nYear = Arabic(m->cYear)
  135.       
  136.        *-- AS Years start at May -- if the month for a specific year is
  137.        *-- Jan through April it's part of the next "real" year ...
  138.        if m->cMonth = "JAN" .or. m->cMonth = "FEB" .or. ;
  139.           m->cMonth = "MAR" .or. m->cMonth = "APR"
  140.           m->nYear = m->nYear + 1
  141.        endif
  142.           
  143.        m->nYear = m->nYear + 65  && SCA dates start at 66 ...
  144.        if m->nYear > 99       && this thing doesn't handle turn of 
  145.                               && the century
  146.           @5,0 clear
  147.           do center with 5,40,"rg+/r","No dates past XXXIV, please"
  148.           loop
  149.        endif
  150.       
  151.        *-- set numeric value of month ...
  152.        do case
  153.           case m->cMonth = "JAN"
  154.              m->nMonth = 1
  155.           case m->cMonth = "FEB"
  156.              m->nMonth = 2
  157.           case m->cMonth = "MAR"
  158.              m->nMonth = 3
  159.           case m->cMonth = "APR"
  160.              m->nMonth = 4
  161.           case m->cMonth = "MAY"
  162.              m->nMonth = 5
  163.           case m->cMonth = "JUN"
  164.              m->nMonth = 6
  165.           case m->cMonth = "JUL"
  166.              m->nMonth = 7
  167.           case m->cMonth = "AUG"
  168.              m->nMonth = 8
  169.           case m->cMonth = "SEP"
  170.              m->nMonth = 9
  171.           case m->cMonth = "OCT"
  172.              m->nMonth = 10
  173.           case m->cMonth = "NOV"
  174.              m->nMonth = 11
  175.           case m->cMonth = "DEC"
  176.              m->nMonth = 12
  177.        endcase
  178.       
  179.        *-- if the day field is empty, assume the middle of the month, 
  180.        *-- so we have SOMETHING to go by ...
  181.        if len(alltrim(m->cDay)) = 0
  182.           m->nDay = 15
  183.        else
  184.           m->nDay = val(m->cDay)
  185.        endif
  186.       
  187.        *-- Check for valid day of the month ...
  188.        if m->nDay > 29 .and. m->nMonth = 2 .or. (m->nDay = 31 .and. ;
  189.          (m->nMonth = 4 .or. m->nMonth = 6 .or. m->nMonth = 9 .or. ;
  190.           m->nMonth = 11))
  191.           do center with 5,40,"rg+/r",;
  192.              chr(7)+"INVALID DATE -- Try again ..."
  193.           loop
  194.        endif
  195.       
  196.        exit                        && out of loop -- if here, we're done
  197.       
  198.     enddo                          && end of loop
  199.  
  200.     *-- Convert it
  201.     m->cDate = transform(m->nMonth,"@L 99")+transform(m->nDay,"@L 99")+;
  202.                transform(m->nYear,"@L 99")
  203.    
  204.     *-- force this 'character' date into the date field on the screen
  205.     keyboard m->cDate clear   && put it into the field, and clear out
  206.                               && keyboard buffer first ...
  207.  
  208.     *-- deal with cleanup ...
  209.     release wind wDate
  210.     restore screen from sDate
  211.     release screen sDate
  212.     set escape &cEscape.
  213.     set exact &cExact.
  214.     on key label F1 do SCA_Real  && reset for user
  215.    
  216. RETURN
  217. *-- EoP: SCA_Real
  218.  
  219. FUNCTION SCA2Real
  220. *-----------------------------------------------------------------------
  221. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  222. *-- Date........: 04/22/1992
  223. *-- Notes.......: Jay figured out a short version of SCA_Real above, 
  224. *--               which does not use screen input/screen display. This 
  225. *--               can be used directly as a function.
  226. *-- Written for.: dBASE IV, 1.5
  227. *-- Rev. History: 04/22/1992 -- Original Release
  228. *-- Calls.......: ALLTRIM()         Function in PROC.PRG
  229. *--               ARABIC()          Function in CONVERT.PRG (and below)
  230. *-- Called by...: Any
  231. *-- Usage.......: SCA2Real(<cDay>,<cMonth>,<cYear>)
  232. *-- Example.....: ?SCA2Real("12","JAN","XXVI")
  233. *-- Returns.....: dBASE Date (from example above: 01/12/92)
  234. *-- Parameters..: cDay   = Character day of month
  235. *--               cMonth = Character day of month
  236. *--               cYear  = Roman Numeric version of year (SCA dates)
  237. *-----------------------------------------------------------------------
  238.  
  239.    parameters cDay, cMonth, cYear
  240.    private nMonth, nDay, nYear
  241.    
  242.    m->nMonth = at(upper(left(m->cMonth,3)),;
  243.          "    JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC") /4
  244.    m->nDay = iif(""=alltrim(m->cDay),15,val(m->cDay))
  245.    m->nYear = arabic(m->cYear)+1965+iif(m->nMonth < 5,1,0)
  246.    
  247. RETURN ctod(right(str(m->nMonth+100),2)+"/";
  248.        +right(str(m->nDay+100),2)+"/"+str(m->nYear))
  249. *-- EoF: SCA2Real()
  250.  
  251. FUNCTION Real_SCA
  252. *-----------------------------------------------------------------------
  253. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) 
  254. *--               (CIS: 71333,1030)
  255. *-- Date........: 07/23/1991
  256. *-- Notes.......: This procedure was designed to handle data entered 
  257. *--               into the Order of Precedence of the Principality of 
  258. *--               the Mists. For the purpose of printing the Order of 
  259. *--               Precedence, it is necessary to convert real dates to 
  260. *--               SCA dates. I needed to store the data as real dates, 
  261. *--               but I want it to print with SCA dates ...
  262. *-- Written for.: dBASE IV, 1.1
  263. *-- Rev. History: 07/23/1991 -- Original Release
  264. *-- Calls.......: ROMAN()              Function in PROC.PRG
  265. *-- Called by...: Any
  266. *-- Usage.......: Real_SCA(<dDate>)
  267. *-- Example.....: @nLine,25 say Real_SCA(CA)  && print SCA date for 
  268. *--                                           && Corolla Aulica
  269. *-- Returns.....: SCA Date based on dDate
  270. *-- Parameters..: dDate = date to be converted
  271. *-----------------------------------------------------------------------
  272.  
  273.    PARAMETERS dDate  && a real date, to be converted to an SCA date 
  274.    private nYear,nMonth,cMonth,cDay
  275.    
  276.    m->nYear  = year(m->dDate) - 1900    && remove the century
  277.    m->nMonth = month(m->dDate)
  278.    m->cMonth = substr(cmonth(m->dDate),1,3) 
  279.                                 && grab only first three characters
  280.    m->cDay   = ltrim(str(day(m->dDate))) 
  281.                                 && convert day to character
  282.    
  283.    *-- First (and most important) is conversion of the year
  284.    *-- this is set to the turn of the century ... (AS XXXV)
  285.    *-- AS Years start at May ... if the month for a specific year 
  286.    *-- is Jan through April it's part of the previous SCA year 
  287.    *-- (April '67 = April AS I, not II)
  288.     
  289.    if m->nMonth < 5
  290.       m->nYear = m->nYear - 1
  291.    endif
  292.    
  293.    m->nYear = m->nYear - 65   && SCA dates start at 66
  294.    m->cYear = Roman(m->nYear)
  295.  
  296. RETURN m->cMonth+" "+m->cDay+", "+"AS "+m->cYear
  297. *-- EoF: Real_SCA()
  298.  
  299. *-----------------------------------------------------------------------
  300. *-- These two functions were included in this library file, so that you 
  301. *-- (or I) do not have to figure a way to combine the functions below 
  302. *-- from CONVERT.PRG and this file into one library file.
  303. *-----------------------------------------------------------------------
  304.  
  305. FUNCTION Roman
  306. *-----------------------------------------------------------------------
  307. *-- Programmer..: Nick Carlin
  308. *-- Date........: 08/27/1993
  309. *-- Notes.......: A function designed to return a Roman Numeral based on
  310. *--               an Arabic Numeral input ...
  311. *-- Written for.: dBASE III+
  312. *-- Rev. History: 04/13/1988 - original function.
  313. *--               07/25/1991 - Ken Mayer - 1) modified for dBASE IV, 
  314. *--                             1.1, 2) updated to a function, and 
  315. *--                             3) the procedure GetRoman was done away
  316. *--                             with (combined into the function).
  317. *--               04/26/1992 - Jay Parsons - shortened (seriously ...)
  318. *--               08/27/1993 - Jay Parsons - dBASE IV 2.0 bug worked 
  319. *--                            around
  320. *-- Calls.......: None
  321. *-- Called by...: Any
  322. *-- Usage.......: Roman(<nArabic>)
  323. *-- Example.....: ? Roman(32)
  324. *-- Returns.....: Roman Numeral (character string) equivalent of Arabic 
  325. *--               numeral passed to it. In example:  XXXII
  326. *-- Parameters..: nArabic = Arabic number to be converted to Roman
  327. *-----------------------------------------------------------------------
  328.  
  329.    parameters nArabic
  330.    private cLetrs,cRoman,nCount,nLeft,nMod,nNines,cAdd
  331.    
  332.    m->cLetrs ="IVXLCDMWY"         && Roman digits
  333.    m->cRoman = ""                 && this will be the returned value
  334.    m->nCount = 0                  && init counter
  335.    m->nLeft = fixed( m->nArabic )
  336.    if m->nLeft < 0 .or. m->nLeft # int( m->nLeft )
  337.      RETURN m->cRoman
  338.    endif
  339.    do while m->nCount < 4 .and. m->nLeft > 0  && loop four times, once 
  340.                                               && each for 1s, 10s, 
  341.                                               && 100s, 1000s
  342.      m->nMod = mod( m->nLeft, 10 )
  343.      m->nLeft = int( m->nLeft / 10 )
  344.      m->cGroup = substr( m->cLetrs, 2 * m->nCount + 1, 3 )
  345.      m->cAdd = ""
  346.      do case
  347.        case m->nMod = 9
  348.          m->cAdd = left( m->cGroup, 1 ) + right( m->cGroup, 1 )
  349.        case m->nMod = 4
  350.          m->cAdd = left( m->cGroup, 2 )
  351.        otherwise
  352.          if m->nMod > 4                    && 5 - 8
  353.            m->cAdd = substr( m->cGroup, 2, 1 )
  354.            m->nMod = m->nMod - 5
  355.          endif
  356.          if m->nMod > 0                    && 1 - 3 and 6 - 8
  357.             m->cAdd = m->cAdd + replicate(left( m->cGroup, 1 ), m->nMod)
  358.          endif
  359.      endcase
  360.      m->cRoman = m->cAdd + m->cRoman
  361.      m->nCount = m->nCount + 1
  362.    enddo  && while nCounter < 4
  363.         
  364. RETURN m->cRoman
  365. *-- EoF: Roman()
  366.  
  367. FUNCTION Arabic
  368. *-----------------------------------------------------------------------
  369. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  370. *-- Date........: 04/26/1992
  371. *-- Notes.......: This function converts a Roman Numeral to an arabic 
  372. *--               one. It parses the roman numeral into an array, and 
  373. *--               checks each character ... if the previous character 
  374. *--               causes the value to subtract (for example, IX = 9, 
  375. *--               not 10) we subtract that value, and then set the 
  376. *--               previous value to 0, otherwise we would get some 
  377. *--               odd values in return. So far, it works fine.
  378. *-- Written for.: dBASE IV, 1.1
  379. *-- Rev. History: 07/15/1991 - original function.
  380. *--               04/26/1992 - Jay Parsons - shortened.
  381. *-- Calls.......: None
  382. *-- Called by...: Any
  383. *-- Usage.......: Arabic(<cRoman>)
  384. *-- Example.....: ?Arabic("XXIV")
  385. *-- Returns.....: Arabic number (from example, 24)
  386. *-- Parameters..: cRoman = character string containing roman numeral to 
  387. *--                        be converted.
  388. *-----------------------------------------------------------------------
  389.  
  390.    parameters cRoman
  391.    private cRom,cLetrs,nLast,nAt,nVal,cChar,nArabic
  392.    
  393.    m->cRom = ltrim(trim(upper(m->cRoman))) 
  394.                            && convert to all caps in case ...
  395.    m->cLetrs = "IVXLCDMWY"
  396.    m->nArabic = 0
  397.    m->nLast = 0
  398.    do while len( m->cRom ) > 0
  399.       m->cChar = right( m->cRom, 1 )
  400.       m->nAt = at( m->cChar, m->cLetrs )
  401.       m->nVal= 10 ^ int( m->nAt/2 ) / iif(m->nAt/2 = int(m->nAt/2),2,1)
  402.       do case
  403.          case m->nAt = 0
  404.             m->nArabic = 0
  405.             exit
  406.          case m->nAt >= m->nLast
  407.             m->nArabic = m->nArabic + m->nVal
  408.             m->nLast = m->nAt
  409.          otherwise
  410.             if m->nAt/2 = int( m->nAt / 2 )
  411.                m->nArabic = 0
  412.                exit
  413.             else
  414.                m->nArabic = m->nArabic - m->nVal
  415.             endif
  416.       endcase
  417.       m->cRom = left( m->cRom, len( m->cRom ) - 1 )
  418.    enddo
  419.    
  420. RETURN m->nArabic
  421. *-- EoF: Arabic()
  422.  
  423. *-----------------------------------------------------------------------
  424. *-- EoP: SCA.PRG
  425. *-----------------------------------------------------------------------
  426.